\ Eighth Compiler

\  push named literals (byte,word)
\  automatically compile number literals (auto-sense width but can override with w:)
\  define asm label
\  direct compile (asm, tables...)
\  if,then,for,next,begin,while,repeat,until,again
\  convert punctuation to assembler-legal text - only applies to definition names


\ words
\  bind to label with alias - output literal or
\  define label (automatically creates "safe" internal version)
\  define routine
\  compile token
\  declare zp variable (whatever size)
\   stack area variable
\   wram variable
\   prg ram variable
\  create local control structure label
\

0 value #1

: fileout-invoke ;
: fileout-revoke ;
: fileout-/input ;
: fileout-type     #1 write-file throw ;
: fileout-emit     pocket c! pocket 1 fileout-type ;
: fileout-?type    ?dup if #1 write-file throw else drop then ;
: fileout-cr       13 fileout-emit 10 fileout-emit ;
: fileout-page   fileout-cr fileout-cr " ------------------------------------------------------------------------------------ " fileout-type fileout-cr ;
: fileout-attribute drop ;


vocabulary DTC

variable lev           \ control structure nesting depth.  don't check for 0 at semi, it will trip false positives when ELSE is used

defer output

: ide-output  cr type ;
: file-output   2dup ide-output fileout-cr  fileout-?type ;
' ide-output is output


: (dw)       "    .dw " <$ $+ $> output  ;
: (lit)   " lit" (dw) (dw) ;
: (2lit)  " twolit" (dw) (dw) ;

: hexval   " $" <$ hex (.) decimal $+ $> ;

: ?alias,
	bl parse ?dup if string, exit then
	drop last @ count string, ;

: create-dtc
	also dtc definitions create ?alias, previous definitions ;

\ add existing label as a definition
: bindword  ( -- <alias> <asmname> )
	create-dtc does> count (dw) ;

\ add existing label as a literal (8-bit)
: bindlit   ( -- <alias> <asmname> )
	create-dtc does> count (lit) ;

\ add existing label as a literal (16-bit)
: bind2lit   ( -- <alias> <asmname> )
	create-dtc does> count (2lit) ;


\ search-and-replace special characters
\   ? -> q   ! -> store  @ -> fetch  + -> plus   - -> minus   = -> equal  # -> num  * -> mul
: sanitize  ( addr c -- addr c )
	" " <$
		bounds do
			i c@ true over case
				[char] ? of 2drop " q" false endof
				[char] ! of 2drop " store" false endof
				[char] @ of 2drop " fetch" false endof
				[char] + of 2drop " plus" false endof
				[char] - of 2drop
					i 1+ i' = if
						" minus"
					else
						" _"
					then
					false
				endof
				[char] = of 2drop " equals" false endof
				[char] > of 2drop " to" false endof
				[char] # of 2drop " num" false endof
				[char] * of 2drop " mul" false endof
				[char] . of 2drop " print" false endof
				[char] ( of 2drop " " false endof
				[char] ) of 2drop " _factor" false endof
				[char] / of 2drop " ex_" false endof
				[char] 0 of i 1+ i' <> if 2drop " zero" false then endof
				[char] 1 of i 1+ i' <> if 2drop " one" false then endof
				[char] 2 of i 1+ i' <> if 2drop " two" false then endof
				[char] 3 of i 1+ i' <> if 2drop " three" false then endof
				[char] 4 of i 1+ i' <> if 2drop " four" false then endof
				[char] 8 of i 1+ i' <> if 2drop " eight" false then endof
			endcase
			if c$+ else $+ then
		loop
	$> ;

\ constant literals
: (constant)  ( n )
	last @ count sanitize string,
	
	( n ) hexval

	last @ count sanitize <$ "  = " $+ $+ $> output ;

: constant8	create (constant) does> count (lit) ;
: constant16	create (constant) does> count (2lit) ;



\ declare variables in various sections
variable sct
: section   ( starting-address size -- <name> )   \ when executed sets current section
	create drop , does> sct ! ;
: reserve   ( n -- <name> )
	sct @ @ dup
		256 < if constant8 else constant16 then
	sct @ +! ;

also dtc definitions
: variable  1 reserve ;
: 2variable 2 reserve ;
previous definitions



\ variable sections
$e0 $20 section zeropage
$140 $40 section stackarea
$400 $400 section wram
$6000 $2000 section prgram

\ drop to asm
: asm{
   [char] } BEGIN
      /SOURCE THIRD SCAN NIP IF
         PARSE output EXIT
      THEN
      /SOURCE output
      REFILL 0=
   UNTIL DROP ;

\ define data label literal (16bit)
: data ( <name> )
	create last @ count sanitize 2dup string, <$ " :" $+ $> output
	does> count (2lit) ;

: directive  ( addr c -- <val> )
	bl parse 2swap <$ "  " $+ $+ $> output ;

also dtc definitions previous
: align   " align" directive ;
: org     " org" directive ;
: pad     " pad" directive ;
definitions



\ control structures
: backlabel   " " <$ lev @ 0 ?do [char] - c$+ loop " l" $+ $> ;
: fwdlabel    " " <$ lev @ 0 ?do [char] + c$+ loop " l" $+ $> ;


: (branchfwd)   " false" (dw)     fwdlabel "    mif " <$ $+ $> output ;
: (branchback)   " false" (dw)    backlabel "    mifback " <$ $+ $> output ;

also dtc definitions previous
: if   lev ++    fwdlabel "    mif " <$ $+ $> output ;
: -if  lev ++    fwdlabel "    mnif " <$ $+ $> output ;
: then   fwdlabel output  lev -- ;
: else   lev ++ (branchfwd)  lev -- fwdlabel output   lev ++ ;
: for  lev ++    backlabel output   " for" (dw) ;
: next    backlabel "    mnext " <$ $+ $> output   lev -- ;
: begin   lev ++   backlabel output   ;
: while   fwdlabel "    mif " <$ $+ $> output ;
: repeat  (branchback)  fwdlabel output  lev -- ;
: again   (branchback)  lev -- ;
: until   backlabel "    mifback " <$ $+ $> output  lev -- ;
definitions

\ force 8-bit literal
: b:   bl parse (lit) ;

\ force 8-bit MSB literal
: msb:   " >" <$ bl parse $+ $> (lit) ;

\ force 8-bit LSB literal
: msb:   " <" <$ bl parse $+ $> (lit) ;

\ force 16-bit literal
: w:   bl parse (2lit) ;

\ force dw
: dw:   bl parse (dw) ;

\ automatic literal compilation
variable lastlen

: num
	dup 0 = if drop " zero" (dw) exit then
	dup abs 256 < lastlen @ 4 < or if $ff and hexval (lit) else $ffff and hexval (2lit) then ;

: nes-WORD-INTERPRETER ( c-addr len -- )
	dup lastlen !
   IS-KNOWN?  IF EXECUTE EXIT THEN
   0 IS-NUMBER? if num exit then
   NOT-DEFINED ;  \ could potentially do "autobinding" this way ... maybe based on a flag to turn off the safety valve so to speak...


defer interpreter
' word-interpreter is interpreter


: (INTERPRETING) ( -- flag )
   BEGIN
      STATE @ 0= WHILE
      BL WORD DUP C@ WHILE
      COUNT interpreter ?STACK
   REPEAT 0<> ELSE 0 THEN ;

' (interpreting) is interpreting    \ god SwiftForth you are stupid



\ define definitions
also dtc definitions previous

: :
	create last @ count sanitize 2dup string, <$ " : colon" $+ $> output
	['] nes-word-interpreter is interpreter
	does> count (dw) ;

: ;	"    semi" output   " " output   0 lev !
	['] word-interpreter is interpreter  ;

: [']   ' >body count (2lit) ;

\ create a definition label (for asm)
: code{  ( <name> )
	create last @ count sanitize 2dup string, <$ " :" $+ $> output   asm{
	does> count (dw) ;


definitions


: [    also forth ;
: ]    previous ;


: script:   data   "    script " output ;



\ core and accessory words
bindword + plus
bindword - minus
bindword ! store
bindword @ fetch
bindword +! plusstore
bindword a! astore
bindword @+ fetchplus
bindword !+ storeplus
bindword a@ afetch
bindword d@+ dfetchplus
bindword d!+ dstoreplus
bindword /! ex_store
bindword /@ ex_fetch
bindword /d! ex_dstore
bindword /d@ ex_dfetch
bindword true true
bindword false false
bindword zero zero
bindword 2* twomul
bindword 4* fourmul
bindword 8* eightmul
bindword 16* sixteenmul
bindword 2/ twodiv
bindword 4/ fourdiv
bindword 8/ eightdiv
bindword 2drop twodrop
bindword drop drop
bindword dup dup
bindword nip nip
bindword 2dup twodup
bindword over over
bindword swap swap
bindword 2swap twoswap
bindword d+ dplus
bindword < less
bindword > greater
bindword 0< zeroless
bindword 0> zerogreater
bindword = equals
bindword u< uless
bindword u> ugreater
bindword exit exit
bindword r r
bindword a+ aplus
bindword popra popra
bindword move move
bindword o! ostore
bindword o+ oplus
bindword xor xor
bindword or or
bindword and andd
bindword @o fetcho
bindword !o storeo
bindword rol rol
bindword a- aminus
bindword andcase andcase
bindword third third
bindword end end



: compile
	#1 >r
	bl parse 2dup <$ " .s" $+ $> 2dup type w/o create-file throw to #1
		['] file-output is output
		also dtc definitions
		<$ " .f" $+ $> included
	previous definitions
	#1 close-file throw
	['] ide-output is output
	r> to #1
;





\ test
\\  \ comment out this line to test


also dtc

10 constant8 abc

zeropage
variable Z1
variable 2Z

wram
256 reserve buffer
256 reserve buffer2


: test
	100 for abc for begin while repeat   begin again    next next  123
	123 ;

: test2   test   begin 1 until   Z1 2Z  0 0 ;

script: entrypoint
	test test2
	end

align $100

previous